home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / CGI shell / cgishell.4th < prev    next >
Text File  |  1995-09-27  |  10KB  |  292 lines
  1. \
  2. \
  3. \  PF Forms Handler Shell  --  version 1.2
  4. \
  5. \
  6. \  (c) Ronald T. Kneusel, 1995
  7. \  (rkneusel@post.its.mcw.edu)
  8. \
  9. \  This code may be used and distributed freely provided the copyright 
  10. \  notice remains intact and my name is mentioned in the documentation.
  11. \
  12. \  Last mod: 27-Sep-95
  13. \  =========================================================================
  14. \
  15. \  Provides a shell for writing CGI applications for use with WebSTAR.  The
  16. \  shell will handle all communication between WebSTAR and the CGI.  It also
  17. \  provides a vocabulary for extracting the information presented by WebSTAR.
  18. \
  19. \
  20. \  @Field ( addr1 addr2 new|append -- )
  21. \
  22. \      Get the post data string for the field whose address is
  23. \      on the stack.  Place the data into the string at addr2.  @Field 
  24. \      will convert characters as necessary.
  25. \
  26. \  @Addr ( addr new|append -- )
  27. \
  28. \      Put the client's IP address in the string at addr
  29. \
  30. \  @Direct ( addr new|append -- )
  31. \
  32. \      Put the direct argument in the string at addr
  33. \
  34. \  @Browser ( addr new|append -- )
  35. \
  36. \      Put the browser type in the string at addr
  37. \
  38. \  REPLY ( addr -- )
  39. \
  40. \      Send the string back to WebSTAR.  Use only within  ae: ... ;ae
  41. \
  42.  
  43.  
  44. ( *************************** String Functions **************************** )
  45.  
  46. : MESSAGE[  \ compiling: ( -- ) enclose subsequent ']'ed string
  47.     CREATE  93 word here  c@ 1+ dup 2 mod +  allot  0 [compile] ,
  48.     DOES>  count drop ;  \ runtime action: ( -- addr )
  49.  
  50. : STRING>>  \ compiling: ( n -- )  number of bytes in the string
  51.     CREATE  allot ;
  52.     
  53. : <> = 0= ; macro
  54.  
  55. : newstr  ( addr -- )  \ zero a string
  56.    0 swap c! ;
  57.  
  58. : length ( addr -- count )  \ length of the string at addr
  59.     dup >r BEGIN dup c@ 0 <> WHILE 1+ REPEAT  r> - ;
  60.  
  61. : strcpy ( str1 str2 -- ) \ copy string 1 to string 2
  62.     dup length + >r  \ automatically append
  63.     BEGIN  dup c@ 0 <>  WHILE
  64.       dup c@ r c!  r> 1+ >r  1+
  65.     REPEAT  0 r> c!  ;
  66.  
  67. : strncpy ( str1 str2 -- ) \ copy as above, clear str2 first
  68.     dup newstr  strcpy ;
  69.  
  70. : 0type ( addr -- )  \ type null terminated string
  71.     dup length dup 0 <> IF type ELSE 2drop THEN ;
  72.     
  73. : >null ( addr -- )  \ convert a counted string into a null terminated string
  74.     dup c@ 2dup + >r swap dup 1+ swap rot cmove  0 r> c! ;
  75.  
  76. : >count ( addr -- ) \ convert a null terminated string into a counted string
  77.     dup length >r dup dup 1+ r cmove  r> swap c! ;  
  78.  
  79. : accept ( addr len -- )  \ like expect but no blank at end of line
  80.     swap dup >r swap expect  0 r r> length 1- c! ;
  81.  
  82.  
  83. ( **************** Apple Event and reply string handler ******************* )
  84.  
  85. \ This code courtesy of C. Heilman
  86.  
  87. 2variable DDATA  4 allot
  88.  
  89. MESSAGE[ SERROR  Empty stack!]
  90.  
  91. ( get AEDesc handle from an Apple Event )
  92. : ?DESC ( d.key d.type -- desc.handle desc.type -1  or  0 )
  93.     0 >r                                  ( room for error        )
  94.     202 +md 2@ 2>r                        ( the AppleEvent handle )
  95.     2swap 2>r  2>r                        ( keyword and type      )
  96.     here a>r                              ( receiving address     )
  97.     ,$ 303C ,$ 812 ,$ A816 ( AEGetParamDesc: move #$812,d0 _Pack8 )
  98.     r> 0= IF                              ( if there is no error  )
  99.       here 4 + 2@  here 2@  -1            ( get data & leave true )
  100.     ELSE  0 THEN ;                        ( or else leave false   )
  101.  
  102. : -DESC ( addr.where.desc.is.stored -- error ) ( remove desc rec. )
  103.     0 >r  a>r                          ( push room and descriptor )
  104.    ,$ 303C ,$ 0204 ,$ A816 ( AEDisposeDesc: move #$0204,d0 _Pack8 )
  105.     r> ;
  106.  
  107. 2variable DSIZE  \ this double variable holds the size of a string in dbuff
  108. variable  DBUFF 2046 allot  \ this block is filled with a text string
  109.  
  110. ( get AE data from an Apple Event )
  111. : ?DATA ( d.key -- addr length -1  or  0 )
  112.     0 >r               \ make room on stack for error
  113.     202 +md 2@ 2>r      \ push theAppleEvent address
  114.     2>r  ,s TEXT 2>r     \ push keyword (from pstack) and desired type (TEXT)
  115.     here a>r              \ push an address to hold the actual type
  116.     dbuff a>r              \ push the data receiving address
  117.     2048 s>d 2>r            \ max number of bytes to read
  118.     dsize a>r                \ push a variable to hold the actual size
  119.     ,$ 303C ,$ 0E11 ,$ A816   \ AEGetParamPtr: move #$812,d0 _Pack8
  120.     r> 0= IF                   \ if there is no error
  121.       dbuff  dsize 2@ drop  -1  \ put address, count and true on pstack
  122.     ELSE  0 THEN ;               \ else false
  123.  
  124. \ Reply to an Apple Event with a string
  125. : REPLY ( addr -- )  \ **** USE INSIDE OF A HANDLER ONLY ****
  126.     dup length                \ how long is it?
  127.     0 >r                      \ put room for error on rstack
  128.     198 +md 2@ 2>r            \ put the ReplyEvent handle on rstack
  129.     ,s ---- 2>r  ,s TEXT 2>r  \ put keyword and type on rstack
  130.     swap a>r  0 2>r           \ put addr & count on rs from pstack
  131.     ,$ 303C ,$ 0A0F ,$ A816   \ AEPutParamPtr: move #$A0F,d0 _Pack8
  132.     r> drop ;                 \ ignore any error
  133.  
  134.  
  135. ( ******************* Words to get field data *********************** )
  136.  
  137.  0 constant NEW     \ start a new string
  138. -1 constant APPEND  \ append at end of existing string
  139.  
  140. variable theAddr    \ holds the address of the string
  141.  
  142. : zeroStr ( -- )  \ zero the string in theAddr
  143.    0 theAddr @  c! ;
  144.  
  145. : >append ( c -- )  \ put a character on the end of theAddr
  146.    theAddr @ length  theAddr @ + dup >r c!     \ character
  147.    0 r> 1+ c! ;  \ null
  148.  
  149. : count>str  ( addr len -- )  \ copy characters into the string
  150.    >r dup r> + swap DO
  151.      r c@ >append
  152.    LOOP ;
  153.  
  154. : h>d ( c -- d )  \ hex digit to decimal, no error checking
  155.    dup 64 > IF  55 -  ELSE  48 -  THEN ;
  156.  
  157. : hex>char ( addr -- addr+2 )  \ convert a %xx sequence into a character
  158.    1+ dup c@  swap  1+ dup c@ swap >r ( save addr )
  159.    h>d swap h>d 16 * +
  160.    dup 32 < IF
  161.      13 = IF  13 >append THEN  \ return character
  162.    ELSE
  163.      >append  \ anything >= space
  164.    THEN
  165.    r> ;  ( pull address )
  166.  
  167. variable <end>  \ where to stop
  168. : count>str+ ( addr len -- )  \ copy characters into the string (filtered)
  169.    swap dup rot +  <end> !
  170.    BEGIN  
  171.      dup <end> @ <   \ not at the end of the string
  172.    WHILE
  173.      dup c@
  174.      dup 43 = IF  drop  32 >append  ELSE  \ pluses to spaces
  175.      dup 37 = IF  drop  ( a) hex>char ELSE  \ non-alphanumeric character
  176.      >append  THEN THEN                   \ alphanumeric character
  177.      1+  \ move to next character
  178.    REPEAT ;
  179.  
  180. create ~cr  3 allot  13 ~cr c! 10 ~cr 1+ c!  0 ~cr 2+ c!
  181. : +crlf  ~cr swap strcpy ;   \ add a <cr><lf> pair
  182.  
  183. message[ ~#1 <html>]
  184. message[ ~#2 </html>]
  185.  
  186. : startString ( addr -- )  ( load the header text into string ) 
  187.    ~#1 swap strcpy ;
  188. : endString ( addr -- ) ~#2 swap strcpy ;  ( ending text )
  189.  
  190. ( *************************** Number <--> String ************************* )
  191.  
  192. : f>str ( f addr -- )   \ convert a float to a string in addr
  193.     depth 4 > IF   \ original CH, modified by RTK
  194.       theAddr !  zeroStr \ dest address
  195.       @pen 2>r  10 +md @ >r  30000 10 +md ! \ move pen offscreen
  196.       3000 3000 !pen f.         \ print float: string is at here
  197.       r> 10 +md !  2r> !pen     \ return pen to origonal position
  198.       here count count>str      \ put it addr
  199.     ELSE serror THEN ;
  200.  
  201. : str>f ( addr -- f )  \ convert a string into a float
  202.    1- >abs fnumber ;
  203.  
  204. ( ********************** User level words ************************* )
  205.  
  206. : @Direct ( addr new|append -- )  \ get the direct argument
  207.    swap theAddr !   \ store the string address
  208.    NEW = IF zeroStr THEN  \ clear the string
  209.    ,s ---- ?data IF  count>str  THEN  \ get the argument
  210. ;
  211.  
  212. : @Addr  ( addr new|append -- )  \ get the IP address
  213.    swap theAddr !   \ store the string address
  214.    NEW = IF zeroStr THEN  \ clear the string
  215.    ,s addr ?data IF count>str  THEN  \ get it
  216. ;
  217.  
  218. : @Browser ( addr new|append -- )  \ get the browser type
  219.    swap theAddr !   \ store string address
  220.    NEW = IF zeroStr THEN
  221.    ,s Agnt ?data IF  count>str  THEN  \ get it
  222. ;
  223.  
  224. \
  225. \ Fetch Field Data
  226. \
  227.  
  228. variable fname   \ holds field name address
  229. variable postend  \ holds end of post data address
  230.  
  231. : [@] ( a offset -- v )  + c@ ;
  232.  
  233. variable sflg
  234. : same? ( str1 str2 -- t|f )  \ true if str1==str2, length from str2
  235.    -1 sflg !
  236.    dup length 0 DO  2dup
  237.       r [@]  swap  r [@]
  238.       <> IF  0 sflg ! leave  THEN
  239.    LOOP  2drop
  240.    sflg @  ;
  241.  
  242. : nextField  ( indx -- indx' eos? )  \ move pointer to the next field name
  243.     \ i.e. advance to 1 beyond next '&' character
  244.     BEGIN
  245.       dup dup c@ 38 <>
  246.       swap postend @ <> and  \ while not '&' and not at end of string
  247.     WHILE 1+
  248.     REPEAT
  249.     dup c@ 0= IF  -1  ELSE  1+ 0  THEN
  250. ;
  251.  
  252. : fData ( addr -- addr' )  \ return pointer to beginning of field data
  253.     BEGIN
  254.       dup dup c@ 61 <>      \ while not an '='
  255.       swap postend @ <> and  \ and not end-of-data
  256.     WHILE 1+                  \ move to next char
  257.     REPEAT
  258.     1+   \ really want to end up pointing just beyond the '='
  259. ;
  260.  
  261. : fLen ( addr -- len )  \ return length of field data
  262.     dup BEGIN
  263.       dup dup c@ 38 <>      \ while not an '&'
  264.       swap postend @ <> and  \ and not end-of-data
  265.     WHILE  1+                 \ move to next char
  266.     REPEAT
  267.     swap -  \ return the length
  268. ;
  269.  
  270. : @Field ( addr1 addr2 new|append -- ) \ get the data for a field
  271.    rot theAddr !
  272.    NEW = IF zeroStr THEN
  273.    fname !  \ address of field name string
  274.    ,s post ?data IF  \ there is post data
  275.      postend !  \ store the length
  276.       dup  postend +! \ and find end of post data address
  277.      ( a ) 0  \ start of string, eos? flag
  278.       BEGIN  0=
  279.       WHILE
  280.         dup fname @ same? \ right field?
  281.         IF
  282.           fData  dup fLen \ yes, move to field data and get length
  283.           count>str+      \ then copy to the output string
  284.           -1              \ flag end of loop
  285.         ELSE
  286.           nextField \ no, move to next
  287.         THEN
  288.       REPEAT
  289.       drop  \ remove addr 
  290.     THEN      
  291. ;
  292.